home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
L' Effet Pommier 3
/
L'Effet Pommier - Volume 03.iso
/
Programmation
/
Alpha ƒ
/
Tcl
/
UserCode
/
Text Filters
/
Unix
/
s2p
Wrap
Text File
|
1994-03-07
|
14KB
|
754 lines
$bin = '/usr/local/bin';
# $RCSfile: s2p.SH,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:18 $
#
# $Log: s2p.SH,v $
# Revision 4.0.1.1 91/06/07 12:19:18 lwall
# patch4: s2p now handles embedded newlines better and optimizes common idioms
#
# Revision 4.0 91/03/20 01:57:59 lwall
# 4.0 baseline.
#
#-----------------------------------------------------------------
# modified 2/94 by Tom Pollard <pollard@chem.columbia.edu>
#
# This version operates without writing to disk or calling the
# C preprocessor, making it usable with the standalone version of
# MacPerl.
#-----------------------------------------------------------------
$indent = 4;
$shiftwidth = 4;
$l = '{'; $r = '}';
$BODY = "" ;
while ($ARGV[0] =~ /^-/) {
$_ = shift;
last if /^--/;
# if (/^-D/) {
# $debug++;
# open(BODY,'>-');
# next;
# }
if (/^-n/) {
$assumen++;
next;
}
if (/^-p/) {
$assumep++;
next;
}
die "I don't recognize this switch: $_\n";
}
if (!$assumen && !$assumep) {
$BODY .= &q(<<'EOT');
: while ($ARGV[0] =~ /^-/) {
: $_ = shift;
: last if /^--/;
: if (/^-n/) {
: $nflag++;
: next;
: }
: die "I don't recognize this switch: $_\\n";
: }
:
EOT
}
$BODY .= &q(<<'EOT');
: #ifdef PRINTIT
: #ifdef ASSUMEP
: $printit++;
: #else
: $printit++ unless $nflag;
: #endif
: #endif
: <><>
: $\ = "\n"; # automatically add newline on print
: <><>
: #ifdef TOPLABEL
: LINE:
: while (chop($_ = <>)) {
: #else
: LINE:
: while (<>) {
: chop;
: #endif
EOT
LINE:
while (<>) {
# Wipe out surrounding whitespace.
s/[ \t]*(.*)\n$/$1/;
# Perhaps it's a label/comment.
if (/^:/) {
s/^:[ \t]*//;
$label = &make_label($_);
if ($. == 1) {
$toplabel = $label;
if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
$_ = <>;
redo LINE; # Never referenced, so delete it if not a comment.
}
}
$_ = "$label:";
if ($lastlinewaslabel++) {
$indent += 4;
$BODY .= &tab.";\n";
$indent -= 4;
}
if ($indent >= 2) {
$indent -= 2;
$indmod = 2;
}
next;
} else {
$lastlinewaslabel = '';
}
# Look for one or two address clauses
$addr1 = '';
$addr2 = '';
if (s/^([0-9]+)//) {
$addr1 = "$1";
$addr1 = "\$. == $addr1" unless /^,/;
}
elsif (s/^\$//) {
$addr1 = 'eof()';
}
elsif (s|^/||) {
$addr1 = &fetchpat('/');
}
if (s/^,//) {
if (s/^([0-9]+)//) {
$addr2 = "$1";
} elsif (s/^\$//) {
$addr2 = "eof()";
} elsif (s|^/||) {
$addr2 = &fetchpat('/');
} else {
&Die("Invalid second address at line $.\n");
}
$addr1 .= " .. $addr2";
}
# Now we check for metacommands {, }, and ! and worry
# about indentation.
s/^[ \t]+//;
# a { to keep vi happy
if ($_ eq '}') {
$indent -= 4;
next;
}
if (s/^!//) {
$if = 'unless';
$else = "$r else $l\n";
} else {
$if = 'if';
$else = '';
}
if (s/^{//) { # a } to keep vi happy
$indmod = 4;
$redo = $_;
$_ = '';
$rmaybe = '';
} else {
$rmaybe = "\n$r";
if ($addr2 || $addr1) {
$space = ' ' x $shiftwidth;
} else {
$space = '';
}
$_ = &transmogrify();
}
# See if we can optimize to modifier form.
if ($addr1) {
if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
$_ !~ / if / && $_ !~ / unless /) {
s/;$/ $if $addr1;/;
$_ = substr($_,$shiftwidth,1000);
} else {
$_ = "$if ($addr1) $l\n$change$_$rmaybe";
}
$change = '';
next LINE;
}
} continue {
@lines = split(/\n/,$_);
for (@lines) {
unless (s/^ *<<--//) {
$BODY .= &tab;
}
$BODY .= $_."\n";
}
$indent += $indmod;
$indmod = 0;
if ($redo) {
$_ = $redo;
$redo = '';
redo LINE;
}
}
if ($lastlinewaslabel++) {
$indent += 4;
$BODY .= &tab.";\n";
$indent -= 4;
}
if ($appendseen || $tseen || !$assumen) {
$printit++ if $dseen || (!$assumen && !$assumep);
$BODY .= &q(<<'EOT');
: #ifdef SAWNEXT
: }
: continue {
: #endif
: #ifdef PRINTIT
: #ifdef DSEEN
: #ifdef ASSUMEP
: print if $printit++;
: #else
: if ($printit)
: { print; }
: else
: { $printit++ unless $nflag; }
: #endif
: #else
: print if $printit;
: #endif
: #else
: print;
: #endif
: #ifdef TSEEN
: $tflag = 0;
: #endif
: #ifdef APPENDSEEN
: if ($atext) { chop $atext; print $atext; $atext = ''; }
: #endif
EOT
$BODY .= &q(<<'EOT');
: }
EOT
}
unless ($debug) {
$HEAD = "\n";
$HEAD .= "#define PRINTIT\n" if $printit;
$HEAD .= "#define APPENDSEEN\n" if $appendseen;
$HEAD .= "#define TSEEN\n" if $tseen;
$HEAD .= "#define DSEEN\n" if $dseen;
$HEAD .= "#define ASSUMEN\n" if $assumen;
$HEAD .= "#define ASSUMEP\n" if $assumep;
$HEAD .= "#define TOPLABEL\n" if $toplabel;
$HEAD .= "#define SAWNEXT\n" if $sawnext;
if ($opens) {$HEAD .= "$opens\n";}
@LINES = split(/^/,$HEAD.$BODY) ;
#
# A very simple substitute for the C preprocessor
#
# This code only interprets #define, #ifdef, #else, and #endif.
#
# It can be used to process the output of the s2p (sed-to-perl) script.
#
# 2/19/94 : by Tom Pollard <pollard@chem.columbia.edu>
#
$printit = 1;
$defs{"EMPTY"} = 0;
foreach (@LINES) {
if (/^#define\s+(\w+)/) {
$defs{$1} = $1 ;
}
elsif (/^#ifdef\s+(\w+)/) {
push(@printstack,$printit) ;
if ($defs{$1}) { push(@ifstack,0) ; }
else { push(@ifstack,$printit) ; $printit = 0 ; }
}
elsif (/^#else/) {
$printit = pop(@ifstack) ;
push(@ifstack,0) ;
}
elsif (/^#endif/) {
$printit = pop(@printstack) ;
pop(@ifstack) ;
}
elsif (/^# [0-9]/) {
next ;
}
elsif (/^[ \t]*$/) {
next ;
}
elsif (/^<><>/) {
next ;
}
elsif ($printit) {
print STDOUT ;
}
}
}
exit;
sub Die {
die $_[0];
}
sub tab {
"\t" x ($indent / 8) . ' ' x ($indent % 8);
}
sub make_filehandle {
local($_) = $_[0];
local($fname) = $_;
if (!$seen{$fname}) {
$_ = "FH_" . $_ if /^\d/;
s/[^a-zA-Z0-9]/_/g;
s/^_*//;
$_ = "\U$_";
if ($fhseen{$_}) {
for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
$_ .= $tmp;
}
$fhseen{$_} = 1;
$opens .= &q(<<"EOT");
: open($_, '>$fname') || die "Can't create $fname: \$!";
EOT
$seen{$fname} = $_;
}
$seen{$fname};
}
sub make_label {
local($label) = @_;
$label =~ s/[^a-zA-Z0-9]/_/g;
if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
$label = substr($label,0,8);
# Could be a reserved word, so capitalize it.
substr($label,0,1) =~ y/a-z/A-Z/
if $label =~ /^[a-z]/;
$label;
}
sub transmogrify {
{ # case
if (/^d/) {
$dseen++;
chop($_ = &q(<<'EOT'));
: <<--#ifdef PRINTIT
: $printit = 0;
: <<--#endif
: next LINE;
EOT
$sawnext++;
next;
}
if (/^n/) {
chop($_ = &q(<<'EOT'));
: <<--#ifdef PRINTIT
: <<--#ifdef DSEEN
: <<--#ifdef ASSUMEP
: print if $printit++;
: <<--#else
: if ($printit)
: { print; }
: else
: { $printit++ unless $nflag; }
: <<--#endif
: <<--#else
: print if $printit;
: <<--#endif
: <<--#else
: print;
: <<--#endif
: <<--#ifdef APPENDSEEN
: if ($atext) {chop $atext; print $atext; $atext = '';}
: <<--#endif
: $_ = <>;
: chop;
: <<--#ifdef TSEEN
: $tflag = 0;
: <<--#endif
EOT
next;
}
if (/^a/) {
$appendseen++;
$command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
$lastline = 0;
while (<>) {
s/^[ \t]*//;
s/^[\\]//;
unless (s|\\$||) { $lastline = 1;}
s/^([ \t]*\n)/<><>$1/;
$command .= $_;
$command .= '<<--';
last if $lastline;
}
$_ = $command . "End_Of_Text";
last;
}
if (/^[ic]/) {
if (/^c/) { $change = 1; }
$addr1 = 1 if $addr1 eq '';
$addr1 = '$iter = (' . $addr1 . ')';
$command = $space .
" if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
$lastline = 0;
while (<>) {
s/^[ \t]*//;
s/^[\\]//;
unless (s/\\$//) { $lastline = 1;}
s/'/\\'/g;
s/^([ \t]*\n)/<><>$1/;
$command .= $_;
$command .= '<<--';
last if $lastline;
}
$_ = $command . "End_Of_Text";
if ($change) {
$dseen++;
$change = "$_\n";
chop($_ = &q(<<"EOT"));
: <<--#ifdef PRINTIT
: $space\$printit = 0;
: <<--#endif
: ${space}next LINE;
EOT
$sawnext++;
}
last;
}
if (/^s/) {
$delim = substr($_,1,1);
$len = length($_);
$repl = $end = 0;
$inbracket = 0;
for ($i = 2; $i < $len; $i++) {
$c = substr($_,$i,1);
if ($c eq $delim) {
if ($inbracket) {
substr($_, $i, 0) = '\\';
$i++;
$len++;
}
else {
if ($repl) {
$end = $i;
last;
} else {
$repl = $i;
}
}
}
elsif ($c eq '\\') {
$i++;
if ($i >= $len) {
$_ .= 'n';
$_ .= <>;
$len = length($_);
$_ = substr($_,0,--$len);
}
elsif (substr($_,$i,1) =~ /^[n]$/) {
;
}
elsif (!$repl &&
substr($_,$i,1) =~ /^[(){}\w]$/) {
$i--;
$len--;
substr($_, $i, 1) = '';
}
elsif (!$repl &&
substr($_,$i,1) =~ /^[<>]$/) {
substr($_,$i,1) = 'b';
}
}
elsif ($c eq '[' && !$repl) {
$i++ if substr($_,$i,1) eq '^';
$i++ if substr($_,$i,1) eq ']';
$inbracket = 1;
}
elsif ($c eq ']') {
$inbracket = 0;
}
elsif ($c eq "\t") {
substr($_, $i, 1) = '\\t';
$i++;
$len++;
}
elsif (!$repl && index("()+",$c) >= 0) {
substr($_, $i, 0) = '\\';
$i++;
$len++;
}
}
&Die("Malformed substitution at line $.\n")
unless $end;
$pat = substr($_, 0, $repl + 1);
$repl = substr($_, $repl+1, $end-$repl-1);
$end = substr($_, $end + 1, 1000);
&simplify($pat);
$dol = '$';
$repl =~ s/\$/\\$/;
$repl =~ s'&'$&'g;
$repl =~ s/[\\]([0-9])/$dol$1/g;
$subst = "$pat$repl$delim";
$cmd = '';
while ($end) {
if ($end =~ s/^g//) {
$subst .= 'g';
next;
}
if ($end =~ s/^p//) {
$cmd .= ' && (print)';
next;
}
if ($end =~ s/^w[ \t]*//) {
$fh = &make_filehandle($end);
$cmd .= " && (print $fh \$_)";
$end = '';
next;
}
&Die("Unrecognized substitution command".
"($end) at line $.\n");
}
chop ($_ = &q(<<"EOT"));
: <<--#ifdef TSEEN
: $subst && \$tflag++$cmd;
: <<--#else
: $subst$cmd;
: <<--#endif
EOT
next;
}
if (/^p/) {
$_ = 'print;';
next;
}
if (/^w/) {
s/^w[ \t]*//;
$fh = &make_filehandle($_);
$_ = "print $fh \$_;";
next;
}
if (/^r/) {
$appendseen++;
s/^r[ \t]*//;
$file = $_;
$_ = "\$atext .= `cat $file 2>/dev/null`;";
next;
}
if (/^P/) {
$_ = 'print $1 if /^(.*)/;';
next;
}
if (/^D/) {
chop($_ = &q(<<'EOT'));
: s/^.*\n?//;
: redo LINE if $_;
: next LINE;
EOT
$sawnext++;
next;
}
if (/^N/) {
chop($_ = &q(<<'EOT'));
: $_ .= "\n";
: $len1 = length;
: $_ .= <>;
: chop if $len1 < length;
: <<--#ifdef TSEEN
: $tflag = 0;
: <<--#endif
EOT
next;
}
if (/^h/) {
$_ = '$hold = $_;';
next;
}
if (/^H/) {
$_ = '$hold .= "\n"; $hold .= $_;';
next;
}
if (/^g/) {
$_ = '$_ = $hold;';
next;
}
if (/^G/) {
$_ = '$_ .= "\n"; $_ .= $hold;';
next;
}
if (/^x/) {
$_ = '($_, $hold) = ($hold, $_);';
next;
}
if (/^b$/) {
$_ = 'next LINE;';
$sawnext++;
next;
}
if (/^b/) {
s/^b[ \t]*//;
$lab = &make_label($_);
if ($lab eq $toplabel) {
$_ = 'redo LINE;';
} else {
$_ = "goto $lab;";
}
next;
}
if (/^t$/) {
$_ = 'next LINE if $tflag;';
$sawnext++;
$tseen++;
next;
}
if (/^t/) {
s/^t[ \t]*//;
$lab = &make_label($_);
$_ = q/if ($tflag) {$tflag = 0; /;
if ($lab eq $toplabel) {
$_ .= 'redo LINE;}';
} else {
$_ .= "goto $lab;}";
}
$tseen++;
next;
}
if (/^y/) {
s/abcdefghijklmnopqrstuvwxyz/a-z/g;
s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
s/abcdef/a-f/g;
s/ABCDEF/A-F/g;
s/0123456789/0-9/g;
s/01234567/0-7/g;
$_ .= ';';
}
if (/^=/) {
$_ = 'print $.;';
next;
}
if (/^q/) {
chop($_ = &q(<<'EOT'));
: close(ARGV);
: @ARGV = ();
: next LINE;
EOT
$sawnext++;
next;
}
} continue {
if ($space) {
s/^/$space/;
s/(\n)(.)/$1$space$2/g;
}
last;
}
$_;
}
sub fetchpat {
local($outer) = @_;
local($addr) = $outer;
local($inbracket);
local($prefix,$delim,$ch);
# Process pattern one potential delimiter at a time.
DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
$prefix = $1;
$delim = $2;
if ($delim eq '\\') {
s/(.)//;
$ch = $1;
$delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
$ch = 'b' if $ch =~ /^[<>]$/;
$delim .= $ch;
}
elsif ($delim eq '[') {
$inbracket = 1;
s/^\^// && ($delim .= '^');
s/^]// && ($delim .= ']');
}
elsif ($delim eq ']') {
$inbracket = 0;
}
elsif ($inbracket || $delim ne $outer) {
$delim = '\\' . $delim;
}
$addr .= $prefix;
$addr .= $delim;
if ($delim eq $outer && !$inbracket) {
last DELIM;
}
}
$addr =~ s/\t/\\t/g;
&simplify($addr);
$addr;
}
sub q {
local($string) = @_;
local($*) = 1;
$string =~ s/^:\t?//g;
$string;
}
sub simplify {
$_[0] =~ s/_a-za-z0-9/\\w/ig;
$_[0] =~ s/a-z_a-z0-9/\\w/ig;
$_[0] =~ s/a-za-z_0-9/\\w/ig;
$_[0] =~ s/a-za-z0-9_/\\w/ig;
$_[0] =~ s/_0-9a-za-z/\\w/ig;
$_[0] =~ s/0-9_a-za-z/\\w/ig;
$_[0] =~ s/0-9a-z_a-z/\\w/ig;
$_[0] =~ s/0-9a-za-z_/\\w/ig;
$_[0] =~ s/\[\\w\]/\\w/g;
$_[0] =~ s/\[^\\w\]/\\W/g;
$_[0] =~ s/\[0-9\]/\\d/g;
$_[0] =~ s/\[^0-9\]/\\D/g;
$_[0] =~ s/\\d\\d\*/\\d+/g;
$_[0] =~ s/\\D\\D\*/\\D+/g;
$_[0] =~ s/\\w\\w\*/\\w+/g;
$_[0] =~ s/\\t\\t\*/\\t+/g;
$_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
$_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
}